ADA Programming Guide/ADA Programming Guide.iso/ada_gnu/adainc/a-direio.adb

Text File | 1996-01-30 | 19KB | 582 lines

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUNTIME COMPONENTS                          --
--                                                                          --
--                        A D A . D I R E C T _ I O                         --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.5 $                             --
--                                                                          --
--           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          --
--                                                                          --
-- The GNAT library is free software; you can redistribute it and/or modify --
-- it under terms of the GNU Library General Public License as published by --
-- the Free Software  Foundation; either version 2, or (at your option) any --
-- later version.  The GNAT library is distributed in the hope that it will --
-- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
-- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
-- Library  General  Public  License for  more  details.  You  should  have --
-- received  a copy of the GNU  Library  General Public License  along with --
-- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
-- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Storage_IO;
with Interfaces.C;          use Interfaces.C;
with Interfaces.C.Strings;  use Interfaces.C.Strings;
with System.File_Aux;       use System.File_Aux;

package body Ada.Direct_IO is

   package Stor_IO is new Ada.Storage_IO (Element_Type => Element_Type);

   type Pstring is access String;

   type File_Control_Block is record
      Name       : chars_ptr := Null_Ptr;
      Mode       : File_Mode;
      Form       : Pstring;
      Descriptor : C_File_Ptr;
      Index      : Positive_Count;
      Size       : Count;
   end record;

   type Open_Type is (Create, Open);

   type C_Mode_Type is array (Open_Type, File_Mode) of chars_ptr;

   C_Mode : C_Mode_Type := (others => (others => Null_Ptr));

   Buffer : Stor_IO.Buffer_Type;

   -----------------------
   -- Local Subprograms --
   -----------------------

   function To_Element_Index (Index : in C_Long_Int) return Positive_Count;
   pragma Inline (To_Element_Index);
   --  Converts from the zero-based byte index which is used by the C file
   --  positioning functions to the one-based element index which is used
   --  by the Ada.Direct_IO routines.

   function To_Byte_Index (Index : in Positive_Count) return C_Long_Int;
   pragma Inline (To_Byte_Index);
   --  Converts from the one-based element index which is used by the
   --  Ada.Direct_IO routines to the zero-based byte index which is used
   --  by the C file positioning functions.

   procedure Confirm_File_Is_Open (File : in File_Type);
   pragma Inline (Confirm_File_Is_Open);
   --  Checks to make sure the given file is open.
   --  If not, it raises Status_Error.

   procedure Confirm_File_Is_Closed (File : in File_Type);
   pragma Inline (Confirm_File_Is_Closed);
   --  Checks to make sure the given file is closed.
   --  If not, it raises Status_Error.

   function New_Temp_File_Name return chars_ptr;
   --  Returns a name that is a valid file name and that is not the same as
   --  the name of an existing external file.

   function Current_Size_Of (File : in File_Type) return Count;
   --  Returns the current size in elements of the external file that is
   --  associated with the given file.  The given file must be open.

   -----------
   -- Close --
   -----------

   procedure Close  (File : in out File_Type) is
   begin
      Confirm_File_Is_Open (File);

      if C_Fclose (File.Descriptor) /= 0 then
         raise Device_Error;
      end if;

      File := null;
   end Close;

   --------------------------
   -- Confirm_File_Is_Open --
   --------------------------

   procedure Confirm_File_Is_Open (File : in File_Type) is
   begin
      if not Is_Open (File) then
         raise Status_Error;
      end if;
   end Confirm_File_Is_Open;

   ----------------------------
   -- Confirm_File_Is_Closed --
   ----------------------------

   procedure Confirm_File_Is_Closed (File : in File_Type) is
   begin
      if Is_Open (File) then
         raise Status_Error;
      end if;
   end Confirm_File_Is_Closed;

   ------------
   -- Create --
   ------------

   procedure Create
     (File : in out File_Type;
      Mode : in File_Mode := Inout_File;
      Name : in String := "";
      Form : in String := "")
   is
   begin
      Confirm_File_Is_Closed (File);
      File := new File_Control_Block;

      --  A null string for Name specifies creation of a temporary file.

      if Name'Length = 0 then
         File.Name := New_Temp_File_Name;
      else
         File.Name := New_String (Name);
      end if;

      File.Descriptor := C_Fopen (Filename => File.Name,
                                  Mode     => C_Mode (Create, Mode));

      --  If the C fopen call fails, it returns a null pointer.

      if C_Void_Ptr (File.Descriptor) = C_Null then
         raise Name_Error;
      end if;

      File.Mode  := Mode;
      File.Form  := new String'(Form);

      --  The size of the external file is needed to implement the Size
      --  function and the End_Of_File function.  The size of the external
      --  file can be found by performing an fseek to the end of the external
      --  file, querying the file position, and then performing another fseek
      --  back to the original position.  This is very portable and reasonably
      --  efficient if done only once.  However, it would be too clumsy to
      --  perform two fseeks every time Size or End_Of_File is called.
      --  Instead, Current_Size_Of (which actually performs the fseeks) is
      --  called only once at the time of the opening of the file.  The size
      --  of the external file is then stored in the file control block.  The
      --  Write procedure is the only procedure that can change the size of
      --  the external file, and it contains code to adjust the size stored
      --  in the file control block if the size of the external file increases.

      File.Size  := Current_Size_Of (File);
      File.Index := 1;
   end Create;

   ---------------------
   -- Current_Size_Of --
   ---------------------

   function Current_Size_Of (File : in File_Type) return Count is
      Current_Byte_Index : C_Long_Int;
      Current_Byte_Size  : C_Long_Int;

   begin
      Current_Byte_Index := C_Ftell (File.Descriptor);

      if C_Fseek (Stream => File.Descriptor,
                  Offset => 0,
                  Whence => C_Seek_End) /= 0 then
         raise Device_Error;
      end if;

      Current_Byte_Size := C_Ftell (File.Descriptor);

      if C_Fseek (Stream => File.Descriptor,
                  Offset => Current_Byte_Index,
                  Whence => C_Seek_Set) /= 0 then
         raise Device_Error;
      end if;

      return To_Element_Index (Current_Byte_Size) - 1;
   end Current_Size_Of;

   ------------
   -- Delete --
   ------------

   procedure Delete (File : in out File_Type) is
      File_Name_To_Delete : chars_ptr;

   begin
      Confirm_File_Is_Open (File);

      --  The file should be closed before calling the C remove function.
      --  If the file is open, the behavior of the remove function is
      --  implementation-defined.  Closing the file, however, means we
      --  lose the info in the file control block, so we have to save the
      --  file name temporarily in order to have it for use with the remove
      --  function.

      File_Name_To_Delete := File.Name;
      Close (File);

      if C_Remove (File_Name_To_Delete) /= 0 then
         raise Use_Error;
      end if;
   end Delete;

   ----------
   -- Form --
   ----------

   function Form (File : in File_Type) return String is
   begin
      Confirm_File_Is_Open (File);
      return File.Form.all;
   end Form;

   -----------
   -- Index --
   -----------

   function Index (File : in File_Type) return Positive_Count is
   begin
      Confirm_File_Is_Open (File);
      return File.Index;
   end Index;

   -------------
   -- Is_Open --
   -------------

   function Is_Open (File : in File_Type) return Boolean is
   begin
      return File /= null;
   end Is_Open;

   ----------
   -- Mode --
   ----------

   function Mode (File : in File_Type) return File_Mode is
   begin
      Confirm_File_Is_Open (File);
      return File.Mode;
   end Mode;

   ----------
   -- Name --
   ----------

   function Name (File : in File_Type) return String is
   begin
      Confirm_File_Is_Open (File);
      return Value (File.Name);
   end Name;

   ------------------------
   -- New_Temp_File_Name --
   ------------------------

   function New_Temp_File_Name return chars_ptr is
      Temp_File_Name   : String := "ADATMPXX";
      C_Temp_File_Name : chars_ptr;

   begin
      C_Temp_File_Name := New_String (Temp_File_Name);
      C_Temp_File_Name := C_Mktemp (C_Temp_File_Name);
      return C_Temp_File_Name;
   end New_Temp_File_Name;

   ----------
   -- Open --
   ----------

   procedure Open
     (File : in out File_Type;
      Mode : in File_Mode;
      Name : in String;
      Form : in String := "")
   is
   begin
      Confirm_File_Is_Closed (File);
      File := new File_Control_Block;

      File.Name := New_String (Name);
      File.Descriptor := C_Fopen (Filename => File.Name,
                                  Mode     => C_Mode (Open, Mode));

      --  If the C fopen call fails, it returns a null pointer.

      if C_Void_Ptr (File.Descriptor) = C_Null then
         raise Name_Error;
      end if;

      File.Mode  := Mode;
      File.Form  := new String'(Form);

      --  The size of the external file is needed to implement the Size
      --  function and the End_Of_File function.  The size of the external
      --  file can be found by performing an fseek to the end of the external
      --  file, querying the file position, and then performing another fseek
      --  back to the original position.  This is very portable and reasonably
      --  efficient if done only once.  However, it would be too clumsy to
      --  perform two fseeks every time Size or End_Of_File is called.
      --  Instead, Current_Size_Of (which actually performs the fseeks) is
      --  called only once at the time of the opening of the file.  The size
      --  of the external file is then stored in the file control block.  The
      --  Write procedure is the only procedure that can change the size of
      --  the external file, and it contains code to adjust the size stored
      --  in the file control block if the size of the external file increases.

      File.Size  := Current_Size_Of (File);
      File.Index := 1;
   end Open;

   ----------
   -- Read --
   ----------

   procedure Read
     (File : in  File_Type;
      Item : out Element_Type;
      From : in  Positive_Count)
   is
   begin
      Confirm_File_Is_Open (File);
      Set_Index (File, From);
      Read (File, Item);
   end Read;

   procedure Read (File : in File_Type; Item : out Element_Type) is
   begin
      Confirm_File_Is_Open (File);

      if File.Mode = Out_File then
         raise Mode_Error;
      end if;

      if End_Of_File (File) then
         raise End_Error;
      end if;

      --  Peforming an fseek here forces the current index stored in the
      --  file control block to match the file position indicator used by
      --  the C file IO functions.  They might not match due to a previous
      --  call to Set_Index.  Additionally, this takes care of the buffering
      --  problem associated with update mode files.  Such files may not mix
      --  reads and writes without an intervening call to fflush or to a
      --  file positioning function (fseek, fsetpos, or rewind).

      if C_Fseek (Stream => File.Descriptor,
                  Offset => To_Byte_Index (File.Index),
                  Whence => C_Seek_Set) /= 0
      then
         raise Device_Error;
      end if;

      --  The C fread function returns the number of elements successfully
      --  read.  Since we only read one element at a time and we have already
      --  checked for end of file, if the number of elements successfully read
      --  does not equal the number of elements requested, it is considered to
      --  be a Device_Error.

      if C_Fread (Ptr    => C_Void_Ptr (Buffer'Address),
                  Size   => C_Size_T (Buffer'Length),
                  Nmemb  => 1,
                  Stream => File.Descriptor) /= 1
      then
         raise Device_Error;
      end if;

      Stor_IO.Read (Buffer, Item);
      File.Index := File.Index + 1;
   end Read;

   -----------
   -- Reset --
   -----------

   procedure Reset  (File : in out File_Type; Mode : in File_Mode) is
      Old_File : File_Type := File;

   begin
      Confirm_File_Is_Open (File);
      Close (File);
      Open (File, Mode, Value (Old_File.Name), Old_File.Form.all);
   end Reset;

   procedure Reset  (File : in out File_Type) is
   begin
      Confirm_File_Is_Open (File);
      Reset (File, File.Mode);
   end Reset;

   ---------------
   -- Set_Index --
   ---------------

   procedure Set_Index (File : in File_Type; To : in Positive_Count) is
   begin
      Confirm_File_Is_Open (File);

      --  It is not an error to set the current index of the given file to
      --  a value which exceeds the current size of the file.

      File.Index := To;
   end Set_Index;

   ----------
   -- Size --
   ----------

   function Size (File : in File_Type) return Count is
   begin
      Confirm_File_Is_Open (File);
      return File.Size;
   end Size;

   ----------------------
   -- To_Element_Index --
   ----------------------

   function To_Element_Index (Index : in C_Long_Int) return Positive_Count is
   begin
      return Positive_Count ((Index / Buffer'Length) + 1);
   end To_Element_Index;

   -------------------
   -- To_Byte_Index --
   -------------------

   function To_Byte_Index (Index : in Positive_Count) return C_Long_Int is
   begin
      return C_Long_Int ((Count (Index) - 1) * Buffer'Length);
   end To_Byte_Index;

   -----------
   -- Write --
   -----------

   procedure Write
     (File : in File_Type;
      Item : in Element_Type;
      To   : in Positive_Count)
   is
   begin
      Confirm_File_Is_Open (File);
      Set_Index (File, To);
      Write (File, Item);
   end Write;

   procedure Write (File : in File_Type; Item : in Element_Type) is
   begin
      Confirm_File_Is_Open (File);

      if File.Mode = In_File then
         raise Mode_Error;
      end if;

      Stor_IO.Write (Buffer, Item);

      --  Peforming an fseek here forces the current index stored in the
      --  file control block to match the file position indicator used by
      --  the C file IO functions.  They might not match due to a previous
      --  call to Set_Index.  Additionally, this takes care of the buffering
      --  problem associated with update mode files.  Such files may not mix
      --  reads and writes without an intervening call to fflush or to a
      --  file positioning function (fseek, fsetpos, or rewind).

      if C_Fseek (Stream => File.Descriptor,
                  Offset => To_Byte_Index (File.Index),
                  Whence => C_Seek_Set) /= 0
      then
         raise Device_Error;
      end if;

      --  The C fwrite function returns the number of elements successfully
      --  written, which will less than the number of elements requested only
      --  if a write error is encountered.  Such a situation is considered to
      --  be a Device_Error.

      if C_Fwrite (Ptr    => C_Void_Ptr (Buffer'Address),
                   Size   => C_Size_T (Buffer'Length),
                   Nmemb  => 1,
                   Stream => File.Descriptor) /= 1
      then
         raise Device_Error;
      end if;

      --  If the size of the file has increased, store the new size in the
      --  file control block.

      if File.Index > File.Size then
         File.Size := File.Index;
      end if;
      File.Index := File.Index + 1;
   end Write;

   -----------------
   -- End_Of_File --
   -----------------

   function End_Of_File (File : in File_Type) return Boolean is
   begin
      Confirm_File_Is_Open (File);

      if File.Mode = Out_File then
         raise Mode_Error;
      end if;

      return Index (File) > Size (File);
   end End_Of_File;

begin
   -------------------------
   -- Package Elaboration --
   -------------------------

   --  The following possible modes for the C fopen function are given here
   --  for reference:

   --  r   open text file for reading
   --  w   truncate to zero length or create text file for writing
   --  a   append; open or create text file for writing at end-of-file
   --  r   open file for reading
   --  w   truncate to zero length or create file for writing
   --  a   append; open or create file for writing at end-of-file
   --  r+  open text file for update (reading and writing)
   --  w+  truncate to zero length or create text file for update
   --  a+  append; open or create text file for update, writing at end-of-file
   --  r+  open file for update (reading and writing)
   --  w+  truncate to zero length or create file for update
   --  a+  append; open or create file for update, writing at end-of-file

   --  Notes:

   --  (1) Opening a file with read mode fails if the file does not exist or
   --  cannot be read.

   --  (2) Opening a file with append mode causes all subsequent writes to the
   --  file to be forced to the then current end-of-file, regardless of
   --  intervening calls to the fseek function.

   --  (3) When a file is opened with update mode, both input and output may be
   --  performed on the associated stream.  However, output may not be directly
   --  followed by input without an intervening call to the fflush function or
   --  to a file positioning function (fseek, fsetpos, or rewind), and input
   --  may not be directly followed by output without an intervening call to a
   --  file positioning function, unless the input operation encounters
   --  end-of-file.

   C_Mode (Create, In_File)    := New_String ("w+");
   C_Mode (Create, Out_File)   := New_String ("w+");
   C_Mode (Create, Inout_File) := New_String ("w+");

   C_Mode (Open,   In_File)    := New_String ("r+");
   C_Mode (Open,   Out_File)   := New_String ("r+");
   C_Mode (Open,   Inout_File) := New_String ("r+");
end Ada.Direct_IO;